home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / prolog / sbprolog / amiga / cmplibsr.zoo / $tprog1.P < prev    next >
Text File  |  1988-09-15  |  16KB  |  420 lines
  1. /************************************************************************
  2. *                                    *
  3. * The SB-Prolog System                            *
  4. * Copyright SUNY at Stony Brook, 1986; University of Arizona,1987    *
  5. *                                    *
  6. ************************************************************************/
  7.  
  8. /*-----------------------------------------------------------------
  9. SB-Prolog is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY.  No author or distributor
  11. accepts responsibility to anyone for the consequences of using it
  12. or for whether it serves any particular purpose or works at all,
  13. unless he says so in writing.  Refer to the SB-Prolog General Public
  14. License for full details.
  15.  
  16. Everyone is granted permission to copy, modify and redistribute
  17. SB-Prolog, but only under the conditions described in the
  18. SB-Prolog General Public License.   A copy of this license is
  19. supposed to have been given to you along with SB-Prolog so you
  20. can know your rights and responsibilities.  It should be in a
  21. file named COPYING.  Among other things, the copyright notice
  22. and this notice must be preserved on all copies. 
  23. ------------------------------------------------------------------ */
  24.  
  25.  
  26. /* begin tprog1.P *************************************************/
  27. /* This program is the beginning of an attempt to write a translator that
  28. will take a preprocessed prolog program and produce a list of PIL
  29. instructions that implements the program.  The preprocessor adds pragma
  30. information to the program to make it possible for it to be processed.  We
  31. use the following representation: 
  32.  
  33.   preddef(Name,Arity,Clauses,Pragma,Exrefs)
  34.     where
  35.     Name is the predicate name.
  36.     Arity is the arity of the predicate.
  37.     Clauses is a list of clause terms that represent the defining rules.
  38.     Pragma is a list, empty for the moment.
  39.     Exrefs is a list (with tail a var) of external references: 
  40.       er(Predname,Ep) where Ep is the entry point addr of predicate
  41.       Predname.
  42.  
  43.   clause(Args,Clause,Pragma)
  44.     where
  45.     Args is a list of the formal parameters in the head of the clause.
  46.       (Arity long).
  47.     Clause is a term representing the literals on the rhs of the rule.
  48.     Pragma is a list; s(_,_) is a symbol table with information
  49.       concerning the variables that appear in the clause. 
  50.       all(y) indicates alloc-dealloc is necessary, all(n) indicates 
  51.       it's not nec.
  52.  
  53. A clause is represented as a term with structure symbols
  54. and(Firstconjunct,Pragma,Secondconjunct),
  55. or(Firstdisjunct,Pragma,Seconddisjunct), not(Negformula,Pragma), or nil if
  56. it is empty.  Goals on the right hand side are represented as:
  57.  
  58. '_call'(Predname,Arglist,Pragma):
  59.     where
  60.     Predname is the predicate name.
  61.     Arglist is the list of arguments.
  62.     Pragma is the pragma; nv(N) means that N is the size of the 
  63.       activation record at this point.
  64.  
  65. For example p(a,b) is represented as '_call'(p,[[a],[b]],[nv(1)]).
  66. Structure and constants are represented as lists, not as normal structures.
  67. Thus f(a,b) would be represented as [f,[a],[b]].  Constants are represented
  68. as 0-ary structures, i.e., lists of length one.  Variables are represented
  69. using v(Vid,Pragma), where Vid is a constant symbol representing the name,
  70. and Pragma is a list.  In the pragma, d(L) indicates that L is the location
  71. in the AR of this variable (or its register if it is a temporary) ; occ(f)
  72. indicates that this is the first occurrence and occ(s) a subsequent
  73. occurrence; k(t) indicates it is a temporary variable, k(p) indicates a
  74. permanent variable, k(u) indicates an unsafe occurrence of a permanent
  75. variable.  k(vh) indicates a void (anonymous) variable occurring at the top
  76. level in the head of a clause, k(vb) indicates a void variable occurring at
  77. the top level in the body of a clause.  */
  78.  
  79. /* For the clauses:
  80.     p(X,a) :- r(Y,X),s(Y,f(g(g(X)),f(Y,b))).
  81.     p(B,c).
  82.     p(f(a,g(X)),f(g(a),X)).
  83.  
  84. The query is:
  85.  
  86. tpred(preddef(p,
  87.        2,
  88.        [clause([v(x,[k(p),d(2),occ(f)]),[a]],
  89.            and('_call'(r,
  90.                 [v(y,[k(p),d(3),occ(f)]),
  91.                  v(x,[k(p),d(2),occ(s)])],
  92.                 [nv(2)]),
  93.                [],
  94.                '_call'(s,
  95.                 [v(y,[k(u),d(3),occ(s)]),
  96.                  [f,[g,[g,v(x,[k(p),d(2),occ(s)])]],
  97.                 [f,v(y,[k(p),d(3),occ(s)]),[b]]]],
  98.                 [nv(2)])
  99.               ),
  100.            [all(y)]),
  101.         clause([v(b,[k(t),d(1),occ(f)]),[c]],nil,[nv(0),all(n)]),
  102.         clause([[f,[a],[g,v(x,[k(t),d(3),occ(f)])]],
  103.             [f,[g,[a]],v(x,[k(t),d(3),occ(s)])]],
  104.            nil,
  105.            [all(n)])
  106.        ],
  107.        []),
  108.       Label,
  109.       Pil,[],Exref).
  110.  
  111. */
  112.  
  113. /* ----------------------------------------------------------------------
  114.  
  115.    change to pragma representation for variables : for greater efficiency,
  116.    the Pragma information for variables is being represented as a term,
  117.    "vrec(Type,Occ,Loc,Misc)" where Type is the type of the variable (k(T)
  118.    in old representation), Occ indicates whether this is a first or
  119.    subsequent occurrence (occ(Occ) of older representation), Loc gives the
  120.    location of the variable (d(Loc) in old representation), and Misc stores
  121.    other information as a list.
  122.  
  123.    - saumya debray, july 8 1985
  124.    ---------------------------------------------------------------------- */
  125.  
  126. /* **********************************************************************
  127. $tprog1_export([$tprog/3]).
  128.  
  129. $tprog1_use($index1,[$index/7]).
  130. $tprog1_use($blist,[$append/3,_,$member1/2]).
  131. $tprog1_use($meta,[_,_,$length/2]).
  132. $tprog1_use($computil1,[$reserve/3,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_]).
  133. $tprog1_use($inline1,[$inline/2]).
  134. $tprog1_use($geninline1,[$geninline/7]).
  135. $tprog1_use($tgoal1,[_,$tpar/8,$tgoalargs/7]).
  136. $tprog1_use($glob,[_,$gennum/1,_]).
  137. $tprog1_use($aux1,[_,_,_,_,_,_,$disj_targ_label/2,_,_]).
  138. $tprog1_use($tcond1,[$tcond/7,$cond_branch/8]).
  139. $tprog1_use($listutil1,[_,$merge/3,_,_,_,_,_,_]).
  140. $tprog1_use($disjunc1,[$disj_branch/8,$optimize_CP/2]).
  141. ********************************************************************** */
  142.  
  143.  
  144. /* $tprog(Progdef,Pil,Pilr) is true if the translation of the Progdef (a
  145. list of Predicates) is the difference list Pil-Pilr.            */
  146.  
  147. $tprog([],Pil,Pil,_).
  148. $tprog([Preddef|Prog],Pil,Pilr,Prag) :-
  149.     $tpred(Preddef,Pil,Pilr1,Prag),
  150.     $tprog(Prog,Pilr1,Pilr,Prag).
  151.  
  152. /* $tpred(Preddef,Label,Pil,Pilr) is true if the translation of Preddef
  153. is the difference list Pil-Pilr, with entry point Label. $tpred loops
  154. through the clauses.  */
  155.  
  156. $tpred(preddef(Pname,Arity,[Oneclause],P),Pil,Pilr,_) :- !,
  157.     ($comp_builtin(Pname,Arity,_) ->
  158.     $umsg(['*** Warning: redefining builtin ',Pname,'/',Arity]) ;
  159.     true
  160.     ),
  161.     $tclause(Oneclause,P,Pil,Pilr,0).
  162. $tpred(preddef(Pname,Arity,CList,P),Pil,Pilr,Prag) :- 
  163.     ($comp_builtin(Pname,Arity,_) ->
  164.         $umsg(['*** Warning: redefining builtin ',Pname,'/',Arity]) ;
  165.         true
  166.     ),
  167.     $index(Pname,Arity,CList,P,Pil,Pil0,Prag,SwList),
  168.     $length(CList,N),
  169.     ((N =< 3, not($member2(trace,Prag)), $tail_rec(CList,Pname,Arity)) ->
  170.         $get_indexinst(Pil,IndList) ;
  171.         IndList = []
  172.     ),
  173.     $tclauses(CList,P,Pil1,Pilr,SwList),
  174.     ((IndList = [Inst|_],
  175.       ($functor(Inst,switchonterm,3) ; $functor(Inst,switchonlist,3))
  176.      ) ->
  177.         $subst_exec(Pil1,Pname,Arity,IndList,Pil0,Pilr) ;
  178.         Pil1 = Pil0
  179.     ).
  180.  
  181. /* $tclauses generates retry and trust instructions for each clause */
  182.  
  183. $tclauses([],_,Pil,Pil,_).
  184. $tclauses([Clause|Restclauses],PredPrag,Pil,Pilr,SwList) :- 
  185.     $tclause(Clause,PredPrag,Pil,Pil1,SwList),
  186.     $tclauses(Restclauses,PredPrag,Pil1,Pilr,SwList).
  187.  
  188.  
  189. /* $tclause(Clause,Pil,Piltail) is true if Pil-Piltail is the code that
  190. translates clause Clause. */
  191.  
  192. $tclause(clause(Args,Body,Prag),PredPrag,[label(L)|Pil],Pilr,SwL) :- 
  193.     $member1(all(A),Prag),
  194.     $member1(label(L),Prag),
  195.     $length(Args,N),
  196.     $reserve(N, [], Tin), !,
  197.     (SwL =:= 1 ->
  198.         $theadpars_swlist(Args,A,L,PredPrag,Pil,Pilr1,Tin,TRegs1) ;
  199.     ((A = y -> Pil = [allocate|Pil1] ; Pil = Pil1),
  200.          $theadpars(Args,1,PredPrag,Pil1,Pilr1,Tin,TRegs1)
  201.     )
  202.     ),
  203.     $tbody(Body,A,Pilr1,Pilr,TRegs1,_,_,0,[]).
  204.  
  205. /* $theadpars_swlist loops through the formal parm list.  It's similar
  206.    to $theadpars, expect that it generates special code for the first
  207.    parameter, to handle the switchonlist instruction properly.       */
  208.  
  209. $theadpars_swlist([Arg1|ARest],A,L,PPrag,Pil,Pilr,Tin,Tout) :-
  210.      $tpar_swlist(Arg1,A,L,Pil,Pilm,Tin,Tmid),
  211.      $theadpars(ARest,2,PPrag,Pilm,Pilr,Tmid,Tout).
  212.  
  213. $tpar_swlist([[]],A,(P,N,L),Pil,Pilr,Tin,Tout) :-
  214.      $concat_atom(L,nil,L1),
  215.      $release(1,Tin,Tout),
  216.      (A = y ->
  217.          Pil = [label((P,N,L1)),allocate,getnil(1)|Pilr] ;
  218.         /* not worth optimizing away getnil if must allocate */
  219.     (L3 = (P,N,L4), $gennum(L4),
  220.           Pil = [getnil(1),label((P,N,L1))|Pilr]
  221.     )
  222.      ).
  223. $tpar_swlist(['.'|Args],A,(P,N,L),Pil,Pilr,Tin,Tout) :-
  224.      $concat_atom(L,lis,L1),
  225.      $release(1,Tin,Tmid),
  226.      L3 = (P,N,L4), $gennum(L4),
  227.      (A = y ->
  228.          (Pil = [allocate, getlist(1)|Pilm1],
  229.      Pilm2 = [allocate,getlist_k(1)|Pilm3]
  230.     ) ;
  231.     (Pil = [getlist(1)|Pilm1],
  232.      Pilm2 = [getlist_k(1)|Pilm3]
  233.     )
  234.      ),
  235.      (Args = [v(_,vrec(t,_,_,_)),v(_,vrec(t,_,_,_))] ->
  236.          ($tsubpars(h,Args,Pilm1,[jump(L3),label((P,N,L1))|Pilm2],Tmid,Tout),
  237.      $tsubpars(h,Args,Pilm3,[label(L3)|Pilr],Tmid,_)
  238.     ) ;
  239.     (Pilm1 = [jump(L3),label((P,N,L1))|Pilm2],
  240.      Pilm3 = [label(L3)|Pilm3a],
  241.      $tsubpars(h,Args,Pilm3a,Pilr,Tmid,Tout)
  242.     )
  243.      ).     
  244.  
  245. /* $theadpars loops through the formal parameter list */
  246.  
  247. $theadpars([],_,_,Pil,Pil,T,T).
  248.  
  249. /* TRin = list of temp registers in use at entry; TRout = list of temps
  250.    in use at exit.                            */
  251.  
  252. $theadpars([Par|Rest],N,PredPrag,Pil,Pilr,TRin,TRout) :-
  253.     $tpar(h,Par,N,Pil,Pil1,TRin,TRmid,PredPrag),
  254.     N1 is N+1,
  255.     $theadpars(Rest,N1,PredPrag,Pil1,Pilr,TRmid,TRout).
  256.  
  257. :- mode($tbody,9,[nv,d,d,d,d,d,d,d,d]).
  258.  
  259. $tbody(nil,_,[proceed|Pil],Pil,T,T,_,_,_) :- !.
  260. $tbody('_call'(Pred,Args,CPrag),A,Pil,Pilr,Tin,Tout,OM,OD,HoldRegs) :-    
  261.     $tbodycall(Args,A,Pil,Pilr,Tin,Tout,OM,OD,HoldRegs,Pred,CPrag).
  262.  
  263. /* ----------- EFFICIENT CODE FOR DISJUNCTIONS/CONDITIONALS ---------- */
  264. /* 
  265.     This is an algorithm to generate efficient code for disjunctions and
  266.     conditionals nested arbitrarily deep.  The emphasis here is to
  267.     avoid chains of branches when different execution paths come together.
  268.     However, instead of tedious scanning of assembly code to detect this,
  269.     we try to avoid it altogether by passing labels around.
  270.  
  271.    The idea is the following: execution branches need come together only
  272.    if the goals are of the form (c1 OR c2) AND c3.  In this case, when we
  273.    see the AND, we generate a label, which is the label of the place where
  274.    the execution paths should meet.  This is then passed into the routines
  275.    that process the disjunction, as a parameter "meet(Label)".
  276.  
  277.    The decision on when to actually emit the "meet" label is decided by
  278.    passing around a parameter, Depth.  This can take a value of 0 or 1.
  279.    A depth value of 0 indicates an "outer disjunction", i.e. a goal of
  280.    the form ( (c1 OR c2) AND c3 ).  A depth value of 1 indicates an "inner
  281.    disjunction", e.g. the inner OR in the case ((c1 OR (c2 OR c3)) AND c4).
  282.    This information is used to determine when to generate the label
  283.    corresponding to the "meet" label: this is generated if and only if
  284.    (i) a meet exists, i.e. is nonvariable, and (ii) the depth is 0.  If
  285.    these conditions are met, the meet label is generated and the depth set
  286.    to 1 so that duplicate labels are not produced.
  287.  
  288.    Things are complicated by the fact that we generally only look at the
  289.    outermost connective (it is expensive to search the tree all the time).
  290.    Thus, it is possible to have a goal of the form
  291.            ( (c1 AND (c2 OR c3) ) AND c4 )
  292.    Here, the paths should come together before c4.  This can be handled as
  293.    before, as it turns out: if the goal is of the form ((c1 OR c2) AND c3),
  294.    then a new meet is generated and passed into the first conjunct (i.e.
  295.    (c1 OR c2), together with a new depth of 0; the meet and depth values
  296.    passed down into the second conjunct c2 are what was passed in from
  297.    above, since this is where the execution paths should subsequently come
  298.    together, if necessary.
  299.  
  300. */
  301.  
  302. $tbody(and(Goal,_,Goals),A,Pil,Pilr,Tin,Tout,OldMeet,OldDepth,HoldRegs) :- 
  303.     (($tprog_contains_branch(Goal),
  304.       NewMeet = meet((branch_targ,-1,MeetLab)), NewDepth = 0,
  305.       $gennum(MeetLab)
  306.      ) ;
  307.      (NewMeet = OldMeet, NewDepth = OldDepth)
  308.     ),
  309.     $tbody(Goal,A,Pil,Pil1,Tin,Tmid,NewMeet,NewDepth,HoldRegs),
  310.     $tbody(Goals,A,Pil1,Pilr,Tmid,Tout,OldMeet,OldDepth,HoldRegs), !.
  311. $tbody(if_then_else(Test,P,TGoal,FGoal),A,Pil,Pilr,Tin,Tout,M,D,HoldRegs0) :-
  312.     $gennum(TLabId), $disj_targ_label(TLabId,TLabel),
  313.     $gennum(FLabId), $disj_targ_label(FLabId,FLabel),
  314.     $member1(tvars(TV),P),
  315.     $append(TV,HoldRegs0,HoldRegs1),
  316.     TrueLabel = label((TLabel,-1,TLabId)),
  317.     FalseLabel = label((FLabel,-1,FLabId)),
  318.     $tcond(Test,TrueLabel,FalseLabel,Pil,[TrueLabel|Pilm],Tin,Tmid,HoldRegs1),
  319.     $cond_branch(Pil1,Pilr,FalseLabel,Pil2,Pil3,M,D,ND),
  320.     $tbody(TGoal,A,Pilm,Pil2,Tmid,Tout0,M,ND,HoldRegs1),
  321.     $merge(Tmid,Tout0,Tout1),
  322.     $tbody(FGoal,A,Pil1,Pil3,Tout1,Tout2,M,ND,HoldRegs0), /* tvar may be in */
  323.     $merge(Tout1,Tout2,Tout), !.        /* branches of an i-t-e */
  324. $tbody(or(Goal,_,Goals),A,Pil,Pilr,Tin,[],Meet,Depth,HoldRegs) :-
  325.     NDisj = (disj_targ,-1,NDisjNum), $gennum(NDisjNum),
  326.     $tprog_getnvars(Goal,Nv),
  327.     XPil = [call( (DLabel,-1),Nv),
  328.             label((DLabel,-1,LabId)),trymeelse(NDisj,0)|XPil1],
  329.     $gennum(LabId), $disj_targ_label(LabId,DLabel),
  330.     $disj_branch(Pil1,Pilr,NDisj,Pilm1,Pilm2,Meet,Depth,NewDepth),
  331.     $tbody(Goal,A,XPil1,Pilm1,Tin,_,Meet,NewDepth,HoldRegs),
  332.     $tbody(Goals,A,Pil1,Pilm2,Tin,_,Meet,NewDepth,HoldRegs),
  333.     $optimize_CP(XPil,Pil), !.
  334.  
  335. $tbodycall(Args,A,Pil,Pilr,Tin,Tout,_,_,HoldRegs,Pred,CPrag) :-
  336.     $member1(lastlit,CPrag),
  337.     !,
  338.     $length(Args, Arity),
  339.     (($inline(Pred,Arity), 
  340.       ((A = y, Pil1 = [deallocate,proceed|Pilr]) ;
  341.        (A = n, Pil1 = [proceed | Pilr])
  342.       ),
  343.       $geninline(Pred,Args,HoldRegs,Pil,Pil1,Tin,Tout)
  344.      ) ;
  345.      (((A = y, Pil1 = [deallocate,execute((Pred,Arity))|Pilr]) ;
  346.        (A = n, Pil1 = [execute((Pred,Arity)) | Pilr])
  347.       ),
  348.       $reserve(Arity,Tin,T1), Tout = [],
  349.       $tgoalargs(Args,1,Pil,Pil1,CPrag,T1,_)
  350.      )
  351.     ).
  352. $tbodycall(Args,_,Pil,Pilr,Tin,Tout,_,_,HoldRegs,Pred,CPrag) :-
  353.     $length(Args, Arity),
  354.     (($inline(Pred,Arity),
  355.       $geninline(Pred,Args,HoldRegs,Pil,Pilr,Tin,Tout)
  356.      ) ;
  357.      (($member1(nv(Nv), CPrag),
  358.        $reserve(Arity,Tin,T1), Tout = [],
  359.        $tgoalargs(Args,1,Pil,[call((Pred,Arity),Nv)|Pilr],CPrag,T1,_)
  360.       )
  361.      )
  362.     ).
  363.  
  364. :- mode($tprog_contains_branch,1,[nv]).
  365.  
  366. $tprog_contains_branch(and(C1,_,C2)) :-
  367.     $tprog_contains_branch(C1) ;
  368.     $tprog_contains_branch(C2).
  369. $tprog_contains_branch(or(_,_,_)).
  370. $tprog_contains_branch(if_then_else(_,_,_,_)).
  371.  
  372. :- mode($tprog_getnvars,2,[nv,d]).
  373.  
  374. $tprog_getnvars('_call'(_,_,CPrag), NVars) :-
  375.     (($member1(nv(NVars),CPrag),
  376.       (NVars = 0 ; true)) ;
  377.      NVars = 0
  378.     ).
  379. $tprog_getnvars(and(Goal,_,_),NVars) :- $tprog_getnvars(Goal,NVars).
  380. $tprog_getnvars(or(Goal,_,_),NVars) :- $tprog_getnvars(Goal,NVars).
  381. $tprog_getnvars(not(Goal,_),NVars) :- $tprog_getnvars(Goal,NVars).
  382. $tprog_getnvars(if_then_else(_,_,Goal,_),NVars) :- $tprog_getnvars(Goal,NVars).
  383.  
  384. $get_indexinst(IList,IndexInst) :- 
  385.     var(IList) ->
  386.         IndexInst = [] ;
  387.         (IList = [Inst|IRest],
  388.          (Inst = label(_) ->
  389.             IndexInst = IndInstRest ; IndexInst = [Inst|IndInstRest]
  390.          ),
  391.          $get_indexinst(IRest,IndInstRest)
  392.         ).
  393.  
  394. $subst_exec(Pil,P,N,IList,Pil0,Pilr) :-
  395.     var(Pil) ->
  396.         Pil0 = Pilr ;
  397.         (Pil = [Inst|IRest],
  398.          (Inst = execute((P,N)) ->
  399.              (Pil0 = ['_$execmarker'|Pil0a],   /* '_$execmarker' tells the peephole */
  400.              $subst_exec1(IList,Pil0a,Pil1)   /*  optimizer that there was an "execute" */
  401.             ) ;                  /*  here.  The PO uses this info to  */
  402.             Pil0 = [Inst|Pil1]          /* when registers can be considered dead */
  403.          ),
  404.          $subst_exec(IRest,P,N,IList,Pil1,Pilr)
  405.         ).
  406.  
  407. $subst_exec1([],L,L).
  408. $subst_exec1([I|IRest],[I|LRest],L) :- $subst_exec1(IRest,LRest,L).
  409.  
  410. $tail_rec([clause(_,Body,_)|ClRest],P,N) :-
  411.     $tail_rec1(Body,P,N) ;
  412.     $tail_rec(ClRest,P,N).
  413.  
  414. $tail_rec1('_call'(P,Args,_),P,N) :- $length(Args,N).
  415. $tail_rec1(and(_,_,G),P,N) :- $tail_rec1(G,P,N).
  416. $tail_rec1(if_then_else(_,_,G1,G2),P,N) :- $tail_rec1(G1,P,N) ; $tail_rec1(G2,P,N).
  417. $tail_rec1(or(G1,_,G2),P,N) :- $tail_rec1(G1,P,N) ; $tail_rec1(G2,P,N).
  418.  
  419. /* end $tprog1.P *************************************************/
  420.